unit QBUtils;

{$I QBuilderVerCtrl.inc}

interface

uses
  {$IFDEF VCL16}
    Winapi.Windows,
    System.SysUtils,
    Vcl.Graphics,
    System.Classes,
    System.Math,
    Vcl.Controls,
    System.Win.Registry,
  {$ELSE}
    Windows,
    SysUtils,
    Graphics,
    Classes,
    Math,
    Controls,
    Registry,
  {$ENDIF}
  {$IFDEF EC_UNICODE}
    ecStrUtils,
    ecUnicode,
    ecRegistry,
  {$ENDIF}
  QBStringTypes;

type
  MatrixType = array[0..2, 0..1] of SmallInt;

  TaqbRegistry = class({$IFDEF EC_UNICODE}TecRegistry{$ELSE}TRegistry{$ENDIF})
    function OpenKey(const Key: aqbString; CanCreate: boolean): Boolean;
    procedure GetKeyNames(Strings: TaqbStrings);
  end;

function IsAggregateExpression(AFieldSource: aqbString;
  AAggregates: TaqbStrings): boolean;

procedure UpperCaseItems(Strings: TaqbStrings);

procedure TransformCoordinates(Points: PPoint; Count: Integer; Matrix:
  MatrixType);

function TransparentBlt(DstDC: HDC; DstX, DstY, DstW, DstH: Integer;
  SrcDC: HDC; SrcX, SrcY: Integer; MaskBMP: HBITMAP; MaskX,
  MaskY: Integer): Boolean;
function IsPointNearLine(ListPoints: TList; Point: TPoint; Del: Real): Integer;

function QuoteString(const S: aqbString; BeginQuote, EndQuote: aqbChar): aqbString;
function ExtractQuotedString(const S: aqbString; BeginQuote, EndQuote: aqbChar): aqbString;
function GetDecodedString(const S: aqbString; QuoteChar, ASCIIChar: aqbChar): aqbString;
function GetEncodedString(const S: aqbString; QuoteChar, ASCIIChar: aqbChar): aqbString;
function EncodeIdent(const S: aqbString): aqbString;
function DecodeIdent(const S: aqbString): aqbString;
function QuoteStringIfNeed(const S: aqbString;
  const BeginQuote, EndQuote: aqbChar): aqbString;

function ExtractTableName(const FieldName: aqbString;
  const Quote1, Quote2: aqbChar): aqbString;
function ExtractFieldName(const FieldName: aqbString;
  const Quote1, Quote2: aqbChar): aqbString;
function QBPos(const Substr, S: aqbString;
  const CaseSensitive: boolean = true): integer;

function IsExpression(const Value: aqbString): boolean;
function IsNumber(const Value: aqbString): Boolean;

{$IFDEF VCL3}
function Min(X, Y: integer): integer;
function Max(X, Y: integer): integer;
function ReplaceStr(const Str, OldText, NewText: aqbString): aqbString;
{$ENDIF}

//function RowHeight(Value: TFont; Grid: Boolean = True): Integer;
//{$IFDEF VCL9} inline; {$ENDIF}

type
  TQBWinControl = class(TWinControl)
  published
  property Font;
  end;


implementation

uses EMSCharacter;

function IsRelative(const Value: aqbString): Boolean;
begin
  Result := not ((Value <> '') and (Value[1] = '\'));
end;

function TaqbRegistry.OpenKey(const Key: aqbString; CanCreate: boolean): Boolean;
var
  TempKey: HKey;
  S: aqbString;
  Disposition: Integer;
  Relative: Boolean;
begin
  S := Key;
  Relative := IsRelative(S);

  if not Relative then Delete(S, 1, 1);
  TempKey := 0;
  if not CanCreate or (S = '') then
  begin
    {$IFDEF EC_UNICODE}
    Result := RegOpenKeyExW(GetBaseKey(Relative), PaqbChar(S), 0,
      Access, TempKey) = ERROR_SUCCESS;
    {$ELSE}
    Result := RegOpenKeyEx(GetBaseKey(Relative), PaqbChar(S), 0,
      Access, TempKey) = ERROR_SUCCESS;
    {$ENDIF}
  end else
    {$IFDEF EC_UNICODE}
    Result := RegCreateKeyExW(GetBaseKey(Relative), PaqbChar(S), 0, nil,
      REG_OPTION_NON_VOLATILE, Access, nil, TempKey, @Disposition) = ERROR_SUCCESS;
    {$ELSE}
    Result := RegCreateKeyEx(GetBaseKey(Relative), PaqbChar(S), 0, nil,
      REG_OPTION_NON_VOLATILE, Access, nil, TempKey, @Disposition) = ERROR_SUCCESS;
    {$ENDIF}
  if Result then
  begin
    if (CurrentKey <> 0) and Relative then S := CurrentPath + '\' + S;
    ChangeKey(TempKey, S);
  end;
end;

procedure TaqbRegistry.GetKeyNames(Strings: TaqbStrings);
var
  Len: DWORD;
  I: Integer;
  Info: TRegKeyInfo;
  S: aqbString;
begin
  Strings.Clear;
  if GetKeyInfo(Info) then
  begin
    SetString(S, nil, Info.MaxSubKeyLen + 1);
    for I := 0 to Info.NumSubKeys - 1 do
    begin
      Len := Info.MaxSubKeyLen + 1;
      {$IFDEF EC_UNICODE}
      RegEnumKeyExW(CurrentKey, I, PaqbChar(S), Len, nil, nil, nil, nil);
      {$ELSE}
      RegEnumKeyEx(CurrentKey, I, PaqbChar(S), Len, nil, nil, nil, nil);
      {$ENDIF}
      Strings.Add(PaqbChar(S));
    end;
  end;
end;

(* // todo
function CalcTextWidth(const AText: string; AControl: TQBWinControl): Integer;
var
  DC: HDC;
  S: string;
  sz: TSize;
begin
  DC := GetDC(AControl.Parent.Handle);
  try
    Result := AControl.Font.Size*3;
    SelectObject(DC, AControl.Font.Handle);
    S := AText;
    if S = '' then S := ' ';
    GetTextExtentPoint32(DC, @S[1], Length(S), sz);
    Result := sz.cx + AControl.Font.Size;
  finally
    ReleaseDC(AControl.Parent.Handle, DC);
  end;
end;

function RowHeight(Value: TFont; Grid: Boolean = True): Integer;
{$IFDEF VCL9} inline; {$ENDIF}
begin
  Result := Trunc(Value.Size*2.55);
  if Grid then
    Result := Result - ((Value.Size-8)div 2);
end;
*)

function IsAggregateExpression(AFieldSource: aqbString; AAggregates: TaqbStrings): boolean;
const
  LDelimiters: array[1..8] of aqbChar = ('+', '-', '*', '/', '|', ',', '(', ' ');
  RBracket = '(';
  SpaceChar = ' ';

  function FindRBracket( APos: Integer; ASource: aqbString ): Boolean;
  var
    i : Integer;
  begin
    Result := False;
    for i := APos to Length(ASource) do
    begin
      if ASource[i] = RBracket then
      begin
        Result := True;
        Break;
      end else if ASource[i] = SpaceChar then
        Continue
      else
        Break;
    end;
  end;

  function FindLDelimiter( APos : Integer ): Boolean;
  begin
    Result := False;
    if (APos > 1) and TEMSCharacter.InArray(AFieldSource[APos-1], LDelimiters) then
      Result := True;
  end;

var
  p, i: Integer;
begin
  Result := False;
  for I := 0 to AAggregates.Count - 1 do
  begin
    p := Pos(AAggregates[i], AFieldSource);
    if (p > 0) and FindRBracket(p+Length(AAggregates[i]), AFieldSource)
    and ((p = 1) or FindLDelimiter(p)) then
    begin
  	  Result := true;
      Break;
    end;
  end;
end;

procedure UpperCaseItems(Strings: TaqbStrings);
var
  I: integer;
begin
  if Assigned(Strings) then
    for I := 0 to Strings.Count - 1 do
      Strings[I] := QBUpperCase(Strings[I]);
end;

procedure TransformCoordinates(Points: PPoint; Count: Integer; Matrix:
  MatrixType);
var
  i: Integer;
  Pt: TPoint;
  pPt: PPoint;
begin
  for i := 0 to Count - 1 do
  begin
    pPt := PPoint(Integer(Points) + sizeof(TPoint) * i);
    Pt.x := pPt.x * Matrix[0, 0] + pPt.y * Matrix[1, 0] + Matrix[2, 0];
    Pt.y := pPt.x * Matrix[0, 1] + pPt.y * Matrix[1, 1] + Matrix[2, 1];
    pPt^ := Pt;
  end;
end;

function TransparentBlt(DstDC: HDC; DstX, DstY, DstW, DstH: Integer;
  SrcDC: HDC; SrcX, SrcY: Integer; MaskBMP: HBITMAP; MaskX,
  MaskY: Integer): Boolean;
const
  ROP_DstCopy = $00AA0029;
var
  MemDC, MaskDC: HDC;
  MemBmp: HBITMAP;
  Save: THandle;
  crText, crBack: TColorRef;
  SavePal: HPALETTE;
begin
  Result := true;
  if (Win32Platform = VER_PLATFORM_WIN32_NT) then
  begin
    MaskBlt(DstDC, DstX, DstY, DstW, DstH, SrcDC, SrcX, SrcY, MaskBmp, MaskX,
      MaskY, MakeRop4(ROP_DstCopy, SrcCopy));
    Exit;
  end;
  SavePal := 0;
  MemDC := CreateCompatibleDC(0);
  MaskDC := CreateCompatibleDC(0);
  try
    MaskBMP := SelectObject(MaskDC, MaskBMP);
    MemBmp := CreateCompatibleBitmap(SrcDC, DstW, DstH);
    Save := SelectObject(MemDC, MemBmp);
    SavePal := SelectPalette(SrcDC, SystemPalette16, False);
    SelectPalette(SrcDC, SavePal, False);
    if SavePal <> 0 then
      SavePal := SelectPalette(MemDC, SavePal, True)
    else
      SavePal := SelectPalette(MemDC, SystemPalette16, True);
    RealizePalette(MemDC);

    BitBlt(MemDC, 0, 0, DstW, DstH, MaskDC, MaskX, MaskY, SrcCopy);
    BitBlt(MemDC, 0, 0, DstW, DstH, SrcDC, SrcX, SrcY, SrcErase);
    crText := SetTextColor(DstDC, $0);
    crBack := SetBkColor(DstDC, $FFFFFF);
    BitBlt(DstDC, DstX, DstY, DstW, DstH, MaskDC, MaskX, MaskY, SrcAnd);
    BitBlt(DstDC, DstX, DstY, DstW, DstH, MemDC, 0, 0, SrcInvert);
    SetTextColor(DstDC, crText);
    SetBkColor(DstDC, crBack);

    if Save <> 0 then
      SelectObject(MemDC, Save);
    DeleteObject(MemBmp);
  finally
    if SavePal <> 0 then
      SelectPalette(MemDC, SavePal, False);
    SelectObject(MaskDC, MaskBMP);
    DeleteDC(MaskDC);
    DeleteDC(MemDC);
  end;
end;

function IsPointNearLine(ListPoints: TList; Point: TPoint; Del: Real): Integer;
var
  CurPoint, NextPoint: TPoint;
  Pt: PPoint;
  I, Len, x, y, x0, x1, y0, y1, Ini, Stop, Dest: Integer;
  K, tek: Extended;
  All: Bool;
begin
  Len := ListPoints.Count;
  for I := 0 to Len - 2 do
  begin
    Result := I;
    Pt := ListPoints.Items[I];
    CurPoint := Pt^;
    Pt := ListPoints.Items[I + 1];
    NextPoint := Pt^;
    if CurPoint.x = NextPoint.x then
    begin
      if ((CurPoint.y >= Point.y) and (NextPoint.y <= Point.y)) or
        ((CurPoint.y <= Point.y) and (NextPoint.y >= Point.y)) then
        if Abs(CurPoint.x - Point.x) <= Del then
          Exit;
    end
    else if CurPoint.y = NextPoint.y then
    begin
      if ((CurPoint.x >= Point.x) and (NextPoint.x <= Point.x)) or
        ((CurPoint.x <= Point.x) and (NextPoint.x >= Point.x)) then
        if Abs(CurPoint.y - Point.y) <= Del then
          Exit;
    end
    else
    begin
      K := (CurPoint.y - NextPoint.y) / (CurPoint.x - NextPoint.x);
      tek := (CurPoint.x - NextPoint.x) / (CurPoint.y - NextPoint.y);
      if Abs(tek) < Abs(K) then
      begin
        K := tek;
        Ini := Min(NextPoint.y, CurPoint.y);
        Stop := Max(NextPoint.y, CurPoint.y);
        x0 := NextPoint.y;
        y0 := NextPoint.x;
        x1 := Point.y;
        y1 := Point.x;
      end
      else
      begin
        Ini := Min(NextPoint.x, CurPoint.x);
        Stop := Max(NextPoint.x, CurPoint.x);
        x0 := NextPoint.x;
        y0 := NextPoint.y;
        x1 := Point.x;
        y1 := Point.y;
      end;
      //short but very slowly (test with 50 000 long segments (~500 000px) in polyline was passed at 5.8 sec)
      (*      for x:=Ini to Stop do begin
              y:=round(K*(x-x0)+y0);
              Dest:=Abs(x-x1)+Abs(y-y1);
              if Dest<=Del then Exit;
            end;(**)
      //more faster method (test with 50 000 long segments (~500 000px) in polyline was passed at 0.01 sec !!!)
      All := false;
      while not All do
      begin
        x := Ini + (Stop - Ini) div 2;
        if x = Ini then
          All := true;
        y := round(K * (x - x0) + y0);
        Dest := Abs(x - x1) + Abs(y - y1);
        if Dest <= Del then
          Exit;
        y := round(K * (x + 1 - x0) + y0);
        tek := Abs(x + 1 - x1) + Abs(y - y1);
        if tek < Dest then
          Ini := x
        else
          Stop := x;
      end;
      if tek <= Del then
        Exit; (**)
    end;
  end;
  Result := -1;
end;

function QuoteString(const S: aqbString; BeginQuote, EndQuote: aqbChar): aqbString;
begin
  if BeginQuote = EndQuote then
    Result := QBQuotedStr(S, BeginQuote)
  else
    Result := BeginQuote + S + EndQuote;
end;

function QuoteStringIfNeed(const S: aqbString;
  const BeginQuote, EndQuote: aqbChar): aqbString;
begin
  if (S = '') or (S[1] <> BeginQuote) or (S[Length(S)] <> EndQuote) then
    Result := QuoteString(S, BeginQuote, EndQuote)
  else
    Result := S;
end;

function ExtractQuotedString(const S: aqbString; BeginQuote, EndQuote: aqbChar): aqbString;
var
  PS, P: PaqbChar;
begin
  Result := S;
  if not ((Length(S) > 1) and (S[1] = BeginQuote)) then
    Exit;

  if BeginQuote = EndQuote then
  begin
    PS := PaqbChar(StrAlloc(Length(S)*SizeOf(aqbChar) + 1*SizeOf(aqbChar)));
    P := PS;
    try
      QBStrPCopy(PS, S);
      Result := QBExtractQuotedStr(PS, BeginQuote);
    finally
      PS := P;
      QBStrDispose(PS);
      PS := nil;
    end;
  end
  else if (S[1] = BeginQuote) and (S[Length(S)] = EndQuote) then
    Result := Copy(S, 2, Length(S) - 2);
end;

function GetDecodedString(const S: aqbString; QuoteChar, ASCIIChar: aqbChar): aqbString;
var
  I, J: integer;
  TmpStr, EncStr: aqbString;
begin
  Result := '';
  TmpStr := S;
  I := Pos(QuoteChar + ASCIIChar, TmpStr);
  while I > 0 do
  begin
    Result := Result + Copy(TmpStr, 1, I - 1);
    Delete(TmpStr, 1, I + Length(QuoteChar + ASCIIChar) - 1);
    I := Pos(QuoteChar, TmpStr);
    EncStr := Copy(TmpStr, 1, I - 1);
    Delete(TmpStr, 1, I + Length(QuoteChar) - 1);
    repeat
      J := Pos(ASCIIChar, EncStr);
      try
        try
          if J > 0 then
            Result := Result + Chr(StrToInt(Copy(EncStr, 1, J - 1)))
          else
            Result := Result + Chr(StrToInt(Copy(EncStr, 1, Length(EncStr))));
        except
        end;
      finally
        if J > 0 then
          Delete(EncStr, 1, J + Length(ASCIIChar) - 1);
        Trim(EncStr);
      end;
    until J < 1;
    I := Pos(QuoteChar + ASCIIChar, TmpStr);
  end;
  Result := Result + TmpStr;
  Result := ExtractQuotedString(Result, QuoteChar, QuoteChar);
end;

function GetEncodedString(const S: aqbString; QuoteChar, ASCIIChar: aqbChar): aqbString;
var
  I: integer;
  TmpStr: aqbString;
  PrevChar: aqbChar;
begin
  Result := '';
  TmpStr := QuoteString(S, QuoteChar, QuoteChar);
  I := 1;
  PrevChar := #255;
  while I <= Length(TmpStr) do
  begin
    if TmpStr[I] < #32 then
    begin
      if PrevChar >= #32 then
        Result := Result + QuoteChar;
      Result := Result + ASCIIChar + IntToStr(Ord(TmpStr[I]));
    end
    else
    begin
      if PrevChar < #32 then
        Result := Result + QuoteChar;
      Result := Result + TmpStr[I];
    end;
    PrevChar := TmpStr[I];
    Inc(I);
  end;
  Result := QuoteChar + Result + QuoteChar;
end;

function EncodeIdent(const S: aqbString): aqbString;
begin
{$IFDEF VCL3}
  Result := ReplaceStr(S, '.', #9);
{$ELSE}
  Result := QBStringReplace(S, '.', #9, [rfReplaceAll]);
{$ENDIF}
end;

function DecodeIdent(const S: aqbString): aqbString;
begin
{$IFDEF VCL3}
  Result := ReplaceStr(S, #9, '.');
{$ELSE}
  Result := QBStringReplace(S, #9, '.', [rfReplaceAll]);
{$ENDIF}
end;

function ExtractTableName(const FieldName: aqbString;
  const Quote1, Quote2: aqbChar): aqbString;
var
  I, QuoteCount: integer;
  S: aqbString;
begin
  Result := '';
  I := Length(FieldName);
  if (I > 0) and (FieldName[I] = Quote2) then
  begin
    Dec(I);
    QuoteCount := 1;
  end
  else
    QuoteCount := 0;
  while I > 0 do
  begin
    if Quote1 = Quote2 then
    begin
      if (FieldName[I] = Quote1) and (QuoteCount > 0) then
        if (I = 1) or (FieldName[I - 1] <> Quote1) then
          Dec(QuoteCount)
        else
          Inc(QuoteCount);
    end
    else
    begin
      if FieldName[I] = Quote2 then
        Inc(QuoteCount)
      else if FieldName[I] = Quote1 then
        Dec(QuoteCount);
    end;
    if (FieldName[I] = '.') and (QuoteCount = 0) then
      Break;
    Dec(I);
  end;
  S := Copy(FieldName, 1, I - 1);
  Result := S;
end;

function ExtractFieldName(const FieldName: aqbString;
  const Quote1, Quote2: aqbChar): aqbString;
var
  S: aqbString;
begin
  S := ExtractTableName(FieldName, Quote1, Quote2);
  if S <> '' then
    S := Copy(FieldName, Length(S) + 2, Length(FieldName) - Length(S) - 1)
  else
    S := FieldName;
  Result := S;
end;

function QBPos(const Substr, S: aqbString;
  const CaseSensitive: boolean = true): integer;
begin
  if CaseSensitive then
    Result := Pos(Substr, S)
  else
    Result := Pos(QBUpperCase(Substr), QBUpperCase(S));
end;

function IsExpression(const Value: aqbString): boolean;
const
  //Operations = ['+', '-', '*', '/', '|', ',', '('];
  Operations: array[1..7] of aqbChar = ('+', '-', '*', '/', '|', ',', '(');
var
  I: integer;
begin
  Result := False;
  if Trim(Value) = '' then
    Exit;

  for I := 1 to Length(Value) do
    //if Value[I] in Operations then     // CharInSet ?
    if TEMSCharacter.InArray(Value[I], Operations) then
    begin
      Result := True;
      Break;
    end;
end;

function IsNumber(const Value: aqbString): Boolean;
begin
  Result := True;
  try
    StrToInt(Value);
  except
    on E: EConvertError do
    begin
      Result := False;
    end;
  end;
end;

{$IFDEF VCL3}

function Min(X, Y: integer): integer;
begin
  if X < Y then
    Result := X
  else
    Result := Y;
end;

function Max(X, Y: integer): integer;
begin
  if X < Y then
    Result := Y
  else
    Result := X;
end;

function ReplaceStr(const Str, OldText, NewText: aqbString): aqbString;
var
  Index: LongInt;
  BeginStr: aqbString;
begin
  Result := '';
  BeginStr := Str;
  Index := Pos(OldText, BeginStr);
  while Index <> 0 do
  begin
    Result := Result + Copy(BeginStr, 1, Index - 1) + NewText;
    Delete(BeginStr, 1, Index + Length(OldText) - 1);
    Index := Pos(OldText, BeginStr);
  end;
  Result := Result + BeginStr;
end;
{$ENDIF}

end.
